home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / rt / system.lisp < prev    next >
Encoding:
Text File  |  1992-03-10  |  7.1 KB  |  245 lines
  1. ;;; -*- Package: rt; Log: c.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the Spice Lisp project at
  5. ;;; Carnegie-Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of Spice Lisp, please contact
  7. ;;; Scott Fahlman (FAHLMAN@CMUC). 
  8. ;;; **********************************************************************
  9. ;;;
  10. ;;; $Header: system.lisp,v 1.7 92/03/10 10:01:15 wlott Exp $
  11. ;;;
  12. ;;; IBM RT VM definitions of various system hacking operations.
  13. ;;;
  14. ;;; Written by Rob MacLachlan
  15. ;;;
  16. ;;; IBM RT conversion by Bill Chiles.
  17. ;;;
  18.  
  19. (in-package "RT")
  20.  
  21.  
  22.  
  23. ;;;; Type frobbing VOPs.
  24.  
  25. (define-vop (get-lowtag)
  26.   (:translate get-lowtag)
  27.   (:policy :fast-safe)
  28.   (:args (object :scs (any-reg descriptor-reg)))
  29.   (:results (result :scs (unsigned-reg)))
  30.   (:result-types positive-fixnum)
  31.   (:generator 1
  32.     (inst nilz result object lowtag-mask)))
  33.  
  34. (define-vop (get-type)
  35.   (:translate get-type)
  36.   (:policy :fast-safe)
  37.   (:args (object :scs (descriptor-reg)))
  38.   (:temporary (:scs (non-descriptor-reg)) ndescr)
  39.   (:results (result :scs (unsigned-reg)))
  40.   (:result-types positive-fixnum)
  41.   (:generator 6
  42.     (let ((other-ptr (gen-label))
  43.       (function-ptr (gen-label))
  44.       (lowtag-only (gen-label))
  45.       (done (gen-label)))
  46.       (test-type object ndescr other-ptr nil other-pointer-type)
  47.       (test-type object ndescr function-ptr nil function-pointer-type)
  48.       (test-type object ndescr lowtag-only nil
  49.          even-fixnum-type odd-fixnum-type list-pointer-type
  50.          structure-pointer-type)
  51.       (inst bx done)
  52.       (inst nilz result object type-mask)
  53.  
  54.       (emit-label function-ptr)
  55.       (load-type result object function-pointer-type)
  56.       (inst b done)
  57.  
  58.       (emit-label lowtag-only)
  59.       (inst bx done)
  60.       (inst nilz result object lowtag-mask)
  61.  
  62.       (emit-label other-ptr)
  63.       (load-type result object other-pointer-type)
  64.       
  65.       (emit-label done))))
  66.  
  67. (define-vop (get-header-data)
  68.   (:translate get-header-data)
  69.   (:policy :fast-safe)
  70.   (:args (x :scs (descriptor-reg)))
  71.   (:results (res :scs (unsigned-reg)))
  72.   (:result-types positive-fixnum)
  73.   (:generator 7
  74.     (loadw res x 0 other-pointer-type)
  75.     (inst sr res type-bits)))
  76.  
  77. (define-vop (get-closure-length)
  78.   (:translate get-closure-length)
  79.   (:policy :fast-safe)
  80.   (:args (x :scs (descriptor-reg)))
  81.   (:results (res :scs (unsigned-reg)))
  82.   (:result-types positive-fixnum)
  83.   (:generator 7
  84.     (loadw res x 0 function-pointer-type)
  85.     (inst sr res type-bits)))
  86.  
  87. ;;; SET-HEADER-DATA -- VOP.
  88. ;;;
  89. ;;; In the immediate case for data, we use the OIL instruction assuming the
  90. ;;; data fits in the number of bits determined by 16 minus type-bits.  Due to
  91. ;;; known uses of this VOP, which only store single digit tags, the above
  92. ;;; assumption is reasonable, although unnecessarily slimy.
  93. ;;;
  94. (define-vop (set-header-data)
  95.   (:translate set-header-data)
  96.   (:policy :fast-safe)
  97.   (:args (x :scs (descriptor-reg) :target res)
  98.      (data :scs (any-reg immediate) :target t2))
  99.   (:arg-types * positive-fixnum)
  100.   (:results (res :scs (descriptor-reg)))
  101.   (:temporary (:scs (non-descriptor-reg) :type random) t1)
  102.   (:temporary (:scs (non-descriptor-reg) :type random :from (:argument 1)) t2)
  103.   (:generator 15
  104.     (loadw t1 x 0 other-pointer-type)
  105.     (inst nilz t1 type-mask)
  106.     (sc-case data
  107.       (any-reg
  108.        (move t2 data)
  109.        ;; Since the data is in fixnum format, it is already shifted by 2 bits.
  110.        (inst sl t2 (- type-bits 2))
  111.        (inst o t1 t2))
  112.       (immediate
  113.        (let ((value (tn-value data)))
  114.      (unless (zerop value)
  115.        (inst oil t1 (ash value type-bits))))))
  116.     (storew t1 x 0 other-pointer-type)
  117.     (move res x)))
  118.  
  119. ;;; MAKE-FIXNUM -- VOP.
  120. ;;;
  121. ;;; This is just used in hashing stuff.  It doesn't necessarily have to
  122. ;;; preserve all the bits in the pointer.  Some code expects a positive number,
  123. ;;; so make sure the right shift is logical.
  124. ;;;
  125. (define-vop (make-fixnum)
  126.   (:args (ptr :scs (any-reg descriptor-reg) :target temp))
  127.   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) temp)
  128.   (:results (res :scs (any-reg descriptor-reg)))
  129.   (:generator 3
  130.     (move temp ptr)
  131.     (inst sl temp 3)
  132.     (inst sr temp 1)
  133.     (move res temp)))
  134.  
  135. (define-vop (make-other-immediate-type)
  136.   (:args (val :scs (any-reg descriptor-reg))
  137.      (type :scs (any-reg descriptor-reg immediate)))
  138.   (:results (res :scs (any-reg descriptor-reg) :from :load))
  139.   (:temporary (:type random  :scs (non-descriptor-reg)) temp)
  140.   (:generator 2
  141.     (move res val)
  142.     (inst sl res (- type-bits 2))
  143.     (sc-case type
  144.       (immediate
  145.        (inst oil res (tn-value type)))
  146.       (t
  147.        ;; Type is a fixnum, so lose those lowtag bits.
  148.        (move temp type)
  149.        (inst sr temp 2)
  150.        (inst o res temp)))))
  151.  
  152.  
  153.  
  154. ;;;; Allocation
  155.  
  156. (define-vop (dynamic-space-free-pointer)
  157.   (:results (int :scs (sap-reg)))
  158.   (:result-types system-area-pointer)
  159.   (:translate dynamic-space-free-pointer)
  160.   (:policy :fast-safe)
  161.   (:generator 6
  162.     (load-symbol-value int *allocation-pointer*)))
  163.  
  164. (define-vop (binding-stack-pointer-sap)
  165.   (:results (int :scs (sap-reg)))
  166.   (:result-types system-area-pointer)
  167.   (:translate binding-stack-pointer-sap)
  168.   (:policy :fast-safe)
  169.   (:generator 6
  170.     (load-symbol-value int *binding-stack-pointer*)))
  171.  
  172. (define-vop (control-stack-pointer-sap)
  173.   (:results (int :scs (sap-reg)))
  174.   (:result-types system-area-pointer)
  175.   (:translate control-stack-pointer-sap)
  176.   (:policy :fast-safe)
  177.   (:generator 1
  178.     (move int csp-tn)))
  179.  
  180.  
  181.  
  182. ;;;; Code object frobbing.
  183.  
  184. (define-vop (code-instructions)
  185.   (:translate code-instructions)
  186.   (:policy :fast-safe)
  187.   (:args (code :scs (descriptor-reg) :target sap))
  188.   (:temporary (:scs (non-descriptor-reg)) ndescr)
  189.   (:results (sap :scs (sap-reg)))
  190.   (:result-types system-area-pointer)
  191.   (:generator 10
  192.     (loadw ndescr code 0 other-pointer-type)
  193.     (inst sr ndescr type-bits)
  194.     (inst sl ndescr word-shift)
  195.     (inst s ndescr other-pointer-type)
  196.     (move sap code)
  197.     (inst a sap ndescr)))
  198.  
  199. (define-vop (compute-function)
  200.   (:args (code :scs (descriptor-reg))
  201.      (offset :scs (signed-reg unsigned-reg)))
  202.   (:arg-types * positive-fixnum)
  203.   (:results (func :scs (descriptor-reg)))
  204.   (:temporary (:scs (non-descriptor-reg)) ndescr)
  205.   (:generator 10
  206.     (loadw ndescr code 0 other-pointer-type)
  207.     (inst sr ndescr type-bits)
  208.     (inst sl ndescr word-shift)
  209.     (inst a ndescr offset)
  210.     (inst a ndescr (- function-pointer-type other-pointer-type))
  211.     (inst a ndescr code)
  212.     (move func ndescr)))
  213.  
  214.  
  215.  
  216. ;;;; Other random VOPs.
  217.  
  218.  
  219. (defknown unix::do-pending-interrupt () (values))
  220. (define-vop (unix::do-pending-interrupt)
  221.   (:policy :fast-safe)
  222.   (:translate unix::do-pending-interrupt)
  223.   (:generator 1
  224.     (inst break pending-interrupt-trap)))
  225.  
  226.  
  227. (define-vop (halt)
  228.   (:generator 1
  229.     (inst break halt-trap)))
  230.  
  231.  
  232.  
  233. ;;;; Dynamic vop count collection support
  234.  
  235. (define-vop (count-me)
  236.   (:args (count-vector :scs (descriptor-reg)))
  237.   (:info index)
  238.   (:temporary (:scs (non-descriptor-reg)) count)
  239.   (:generator 1
  240.     (let ((offset
  241.        (- (* (+ index vector-data-offset) word-bytes) other-pointer-type)))
  242.       (inst l count count-vector offset)
  243.       (inst inc count 1)
  244.       (inst st count count-vector offset))))
  245.